perm filename SCANNR.SAI[PNT,HE]1 blob
sn#463372 filedate 1979-08-05 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00008 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 IFCR NOT DECLARATION($$PRGID) THENC
C00003 00003 ! scanning routines
C00004 00004 ! pop,mty, push devstack
C00006 00005 ! expandmacro
C00009 00006 ! parse: number,nums,GTOKEN,namefile
C00019 00007 INTERNAL SIMPLE PROCEDURE SEMICOL_READ
C00023 00008 ! input from different sources
C00027 ENDMK
C⊗;
IFCR NOT DECLARATION($$PRGID) THENC
ENTRY;
BEGIN "SCANNER" ENDC
DEFINE $SCANNER = TRUE ;
REQUIRE "HEADER.SAI" SOURCE_FILE;
! scanning routines;
STRING PROCEDURE SSCAN(REFERENCE STRING SOURCE; INTEGER BRK; REFERENCE INTEGER BRCHR);
BEGIN
STRING S1,SS;
INTEGER L;
S1←SOURCE;
SS←SCAN(SOURCE,BRK,BRCHR);
IF (L←LENGTH(S1)-LENGTH(SOURCE))>0 THEN
$CLNSAVE←$CLNSAVE&SS[1 TO L];
RETURN(SS);
END;
! pop,mty, push devstack;
RCLASS DEVSTACK(INTEGER DEV,DSKCHN; STRING $CLNE,$CLINR,$CRBODY;
RPTR(DEVSTACK)NEXT);
RPTR(DEVSTACK) DEVSTACKTOP;
STRING $CRBODY;
INTERNAL PROCEDURE POPDEVSTACK;
BEGIN
IF DEVSTACKTOP=NULL_RECORD THEN ERROR("cant pop device stack, already at bottom");
IF DEVICE=DSK_X THEN RELEASE($INPCH);
DEVICE←DEVSTACK:DEV[DEVSTACKTOP];
IF DEVICE=DSK_X THEN BEGIN $INPCH←DEVSTACK:DSKCHN[DEVSTACKTOP]; $EOF←FALSE; END;
$CLNE←DEVSTACK:$CLNE[DEVSTACKTOP];
$CLINR←DEVSTACK:$CLINR[DEVSTACKTOP];
$CRBODY←DEVSTACK:$CRBODY[DEVSTACKTOP];
DEVSTACKTOP←DEVSTACK:NEXT[DEVSTACKTOP];
END;
INTERNAL PROCEDURE MTYDEVSTACK;
BEGIN BOOLEAN FLAG; STRING S;
WHILE DEVSTACKTOP≠NULL_RECORD DO POPDEVSTACK;
DO S←INCHSL(FLAG) UNTIL FLAG=TRUE; ! CLEARS TYPEAHEAD ;
$CLNE←$CLINR←$CRBODY←NULL;
DEVICE←TTY_X;
END;
INTERNAL PROCEDURE PUSHDEVSTACK;
BEGIN
RPTR(DEVSTACK) D1;
D1←NEW_RECORD(DEVSTACK);
IF (DEVSTACK:DEV[D1]←DEVICE)=DSK_X THEN
BEGIN DEVSTACK:DSKCHN[D1]←$INPCH;
$INPCH← - 1; END;
DEVSTACK:$CLNE[D1]←$CLNE;
DEVSTACK:$CLINR[D1]←$CLINR;
DEVSTACK:$CRBODY[D1]←$CRBODY;
$CLNE←$CLINR←$CRBODY←NULL;
DEVSTACK:NEXT[D1]←DEVSTACKTOP;
DEVSTACKTOP←D1;
END;
! expandmacro;
INTEGER DUMMYDL;
PROCEDURE BTINIT;
SETBREAK(DUMMYDL←GETBREAK,DUMMY_DELIM,NULL,"IS");
REQUIRE BTINIT INITIALIZATION;
STRING PROCEDURE EXPANDPROC(RPTR(SYMBOL)S1);
BEGIN RPTR(MACRO) MOT;
STRING PARAM,CRBODY,CURBODY;
INTEGER BRCHAR,DLCOUNT,NPARAM;
STRING SAV$CLNSAV;
SAV$CLNSAV←$CLNSAVE[1 TO ∞ - LENGTH(TOKEN)];
NOEXPAND ← TRUE;
IF (NPARAM←MACRO:NPARAM[MOT←SYMBOL:OBJECT[S1]])≠ 0
THEN α "parametered macro"
STRING ARRAY ACTPRMS[1:NPARAM]; INTEGER I;
WORD_READ("(");
FOR I←1 STEP 1 UNTIL NPARAM
DO α "count parameters"
GTOKEN;
IF EQU(TOKEN,"⊂")
THEN α INTEGER J; STRING TTOKEN;
DLCOUNT ← 1; TTOKEN←NULL;
DO α
J←READTILL("⊂⊃");
TTOKEN←TTOKEN&TOKEN&J;
IF J = "⊂"
THEN DLCOUNT ← DLCOUNT + 1
ELSE DLCOUNT ← DLCOUNT - 1;
β UNTIL DLCOUNT=0;
ACTPRMS[I]←TTOKEN[1 TO ∞-1];
β
ELSE ACTPRMS[I]←TOKEN;
GTOKEN;
IF TOKEN≠"," AND I<NPARAM THEN
ERROR("MACRO EXPANSION: comma expected here");
β "count parameters";
IF TOKEN≠")"
THEN ERROR("MACRO EXPANSION: mismatched number of parameters");
CRBODY ← NULL;
CURBODY ← MACRO:BODY[MOT];
WHILE NOT EQU(CURBODY,NULL)
DO α INTEGER I;
CRBODY←CRBODY&SCAN(CURBODY,DUMMYDL,BRCHAR);
PARAM←SCAN(CURBODY,DUMMYDL,BRCHAR);
FOR I←1 STEP 1 UNTIL MACRO:NPARAM[MOT] DO
IF EQU(PARAM,MACRO:PRLIST[MOT][I]) THEN
α PARAM←ACTPRMS[I];DONE; β;
IF I>MACRO:NPARAM[MOT] AND BRCHAR≠0
THEN ERROR("EXPANDMACRO ERROR: ????");
CRBODY ← CRBODY & PARAM;
β;
β "parametered macro"
ELSE CRBODY ← MACRO:BODY[MOT];
NOEXPAND ← FALSE;
$CLNSAVE←SAV$CLNSAV;
RETURN(CRBODY);
END;
! parse: number,nums,GTOKEN,namefile ;
! checks if num is a number or @;
SIMPLE BOOLEAN PROCEDURE NUMBER(INTEGER NUM);
RETURN( "0"≤NUM≤"9" OR NUM="@");
! checks if the string word contains only numbers;
SIMPLE BOOLEAN PROCEDURE NUMS(STRING WORD);
BEGIN "NS"
STRING WW; INTEGER BR;
WW←SCAN(WORD,$NUMTAB,BR);
IF BR=0 THEN RETURN (TRUE) ELSE RETURN (FALSE);
END "NS";
! returns true if the last TOKEN is a terminal character, CR or ;
INTERNAL SIMPLE BOOLEAN PROCEDURE FINAL;
RETURN(TOKEN=SEMC OR TOKEN=CR OR TOKEN=NULL);
! ignores input up to and including the next occurence of CHAR;
INTERNAL SIMPLE PROCEDURE READTO(STRING CHAR);
BEGIN INTEGER I,BRCHAR; STRING R;
SETBREAK(I←GETBREAK, CHAR, NULL, "IA");
R←SSCAN($CLINR,I,BRCHAR);
WHILE BRCHAR≠CHAR DO BEGIN NEWLINE; R←SCAN($CLINR,I,BRCHAR); END;
RELBREAK(I);
END;
! returns in TOKEN the string upto but not including characters in CHARS:
The break character is retained in the input string;
INTERNAL SIMPLE INTEGER PROCEDURE READTILL(STRING CHARS);
BEGIN INTEGER I,BRCHAR; STRING R;
SETBREAK(I←GETBREAK, CHARS, NULL, "IS");
R←SSCAN($CLINR,I,BRCHAR);
WHILE BRCHAR=NULL DO BEGIN NEWLINE; R←R&CRLF&SSCAN($CLINR,I,BRCHAR); END;
RELBREAK(I); TOKEN←R;
RETURN(BRCHAR);
END;
INTERNAL RECURSIVE PROCEDURE GTOKEN (BOOLEAN MUSTGETTOKEN(TRUE));
BEGIN "GTOKEN"
STRING WORD,WORD2;
INTEGER BRPARS; LABEL AGAIN; BOOLEAN NONSTOP;
! reads next RTOKEN using the indicated breaktable;
REQUIRE "<><>" DELIMITERS;
define rtoken(aaa)=<scan($CLINR, aaa ,brpars)>;
define rstoken(aaa)=<sscan($CLINR, aaa ,brpars)>;
IF STOKEN THEN BEGIN STOKEN←FALSE;RETURN;END;
tokenlevel←tokenclass←tokenindex←0;
NONSTOP←MUSTGETTOKEN OR (DEVICE=DSK_X);
AGAIN: IF NONSTOP THEN WHILE $CLINR=NULL DO NEWLINE;
WORD←NULL; #TOKEN←UNDECLARED_TYPE;
RSTOKEN($SPCTAB); ! skips blanks;
WORD←WORD&RSTOKEN($RETAB); ! reads first RTOKEN;
IF WORD=NULL
THEN IF BRPARS="."
THEN BEGIN ! no object read, period found;
RSTOKEN($SKTAB);
RSTOKEN($ALFTAB); ! reads one character;
IF NUMBER(BRPARS)
THEN BEGIN
WORD←"."&RSTOKEN($NUMTAB); ! reads until finds numbers;
#TOKEN ←REAL_TYPE; ! floating number read;
END
ELSE BEGIN
WORD←".";
#TOKEN ←OPERATOR_TYPE; ! period is only a punctuation mark;
END;
END
ELSE IF (BRPARS=CR or BRPARS=NULL) AND NONSTOP
THEN BEGIN
NEWLINE;
GO TO AGAIN;
END
ELSE IF BRPARS="{"
THEN BEGIN "comment found"
READTO("}");
GO TO AGAIN;
END
ELSE IF BRPARS="⊗"
THEN BEGIN
WORD←OLDOBJ;
RSTOKEN($SKTAB);
#TOKEN←ID_TYPE;
END
ELSE BEGIN
WORD←BRPARS;
RSTOKEN($SKTAB);
#TOKEN ←OPERATOR_TYPE; ! punctuation mark found;
END
ELSE IF BRPARS="."
THEN IF NUMS(WORD)
THEN BEGIN
WORD←WORD&".";
RSTOKEN($SKTAB);
RSTOKEN($ALFTAB); ! reads one character;
IF NUMBER(BRPARS)
THEN WORD←WORD&RSTOKEN($NUMTAB);
! there are more numbers;
#TOKEN ←REAL_TYPE; ! floating number read;
END;
TOKEN←WORD;
! checks if RTOKEN is an integer number;
IF TOKEN
THEN
IF #TOKEN =UNDECLARED_TYPE
THEN BEGIN
WORD2←SSCAN(WORD,$ALFTAB,BRPARS); ! reads one character;
IF NUMBER(BRPARS)
THEN BEGIN ! if first ch. is a number;
WORD2←SSCAN(WORD,$NUMTAB,BRPARS);
IF BRPARS=0
THEN BEGIN ! only numbers found;
#TOKEN ←INT_TYPE; ! integer number read;
TOKEN←WORD2;
END
ELSE BEGIN
TOKEN←NULL; ! incorrect TOKEN;
ERROR ($SYNMSG[31],NULL);
END
END;
END;
IF #TOKEN=UNDECLARED_TYPE
THEN IF DECSTR(TOKEN)≠0
THEN #TOKEN←RES_TYPE
ELSE begin "check for id"
RPTR(SYMBOL)S; RPTR(BLOCKREC)BR;
IF CURPROC THEN
IF EQU(TOKEN,SYMBOL:PNAME[CURPROC])
THEN BEGIN #TOKEN←ID_TYPE;TOKENPTR←CURPROC;
RETURN; END;
BR←CURBLOCK;
WHILE BR DO
BEGIN "check local variables"
S←SEARCHBLOCK(TOKEN,BR);
IF S THEN BEGIN #TOKEN←ID_TYPE;
TOKENPTR←S; TOKENLEVEL←BLOCKREC:LEVEL[BR];
TOKENINDEX←SYMBOL:TYPE[S]; RETURN; END;
BR←BLOCKREC:NEXT[BR];
END "check local variables";
IF #TOKEN=UNDECLARED_TYPE THEN
IF (TOKENPTR←CHECKTOT(TOKEN))≠NULL_RECORD
THEN BEGIN #TOKEN←ID_TYPE;
IF (TOKENINDEX←SYMBOL:TYPE[TOKENPTR])=#MC
AND ¬NOEXPAND THEN
BEGIN STRING SSS;
SSS←EXPANDPROC(TOKENPTR);
PUSHDEVSTACK;
$CRBODY←SSS;
DEVICE←MAC_X;
GTOKEN;
END;
END;
end "check for id";
END "GTOKEN";
! reads a file name and returns it ;
INTERNAL STRING PROCEDURE NAMEFILE;
BEGIN "NAMEFILE"
STRING NAME;
GTOKEN;
NAME←TOKEN; ! name of file;
GTOKEN(FALSE);
IF #TOKEN =REAL_TYPE
THEN IF TOKEN="."
THEN BEGIN NAME←NAME&TOKEN; GTOKEN(FALSE); END
ELSE ERROR($SYNMSG[21],$SYNMSG[25])
ELSE IF EQU(TOKEN,".")
THEN BEGIN "EXT" ! extension;
GTOKEN; NAME←NAME&"."&TOKEN; GTOKEN(FALSE);
END "EXT";
IF TOKEN="["
THEN BEGIN "PPN" ! there is ppn;
GTOKEN;
NAME←NAME&"["&TOKEN; GTOKEN(FALSE);
IF TOKEN=","
THEN BEGIN "PN"
GTOKEN(FALSE); ! there is pn;
IF TOKEN=NULL THEN RETURN(NAME);
NAME←NAME&","&TOKEN;
GTOKEN(FALSE);
IF TOKEN="]" OR TOKEN=NULL THEN NAME←NAME&"]"
ELSE ERROR($SYNMSG[4],$SYNMSG[25]);
END "PN"
ELSE IF TOKEN=NULL
THEN RETURN(NAME)
ELSE ERROR($SYNMSG[1],$SYNMSG[25]);
END "PPN"
ELSE STOKEN←TRUE;
RETURN(NAME);
END "NAMEFILE";
INTERNAL SIMPLE PROCEDURE SEMICOL_READ;
BEGIN
GTOKEN(FALSE);
IF NOT FINAL THEN ERROR($SYNMSG[0],$SYNMSG[25]);
END;
INTERNAL SIMPLE PROCEDURE WORD_READ(STRING S);
BEGIN
GTOKEN;
IF NOT EQU(TOKEN,S) THEN ERROR("----→ "&S&" required ←-----");
END;
INTERNAL SIMPLE STRING PROCEDURE IDF_READ;
BEGIN
GTOKEN;
IF #TOKEN =INT_TYPE OR #TOKEN=REAL_TYPE OR #TOKEN=OPERATOR_TYPE
THEN ERROR($SYNMSG[21],$SYNMSG[25])
ELSE RETURN(TOKEN);
END;
INTERNAL SIMPLE STRING PROCEDURE MVFR_READ;
BEGIN
GTOKEN;
IF EQU(TOKEN,"BY")
THEN BEGIN STOKEN←TRUE; RETURN("BARM"); END
ELSE IF #TOKEN=ID_TYPE
THEN RETURN(TOKEN)
ELSE ERROR($SYNMSG[21],$SYNMSG[25]);
END;
INTERNAL SIMPLE STRING PROCEDURE HAND_READ;
BEGIN ! reads BHAND or YHAND (default= BHAND);
GTOKEN;
IF EQU(TOKEN,"BHAND") OR EQU(TOKEN,"YHAND")
THEN RETURN(TOKEN)
ELSE IF EQU(TOKEN,"TO") OR EQU(TOKEN,"BY")
THEN BEGIN STOKEN←TRUE; RETURN("BHAND"); END
ELSE ERROR($SYNMSG[19],$SYNMSG[25]);
END;
INTERNAL SIMPLE STRING PROCEDURE ARM_READ;
BEGIN ! reads "BARM" or "YARM" (default=BARM);
GTOKEN(FALSE);
IF EQU(TOKEN,"YARM") OR EQU(TOKEN,"BARM")
THEN RETURN(TOKEN)
ELSE IF TOKEN=";" OR FINAL
THEN BEGIN STOKEN←TRUE; RETURN("BARM"); END
ELSE ERROR($SYNMSG[18],$SYNMSG[25]);
END;
INTERNAL SIMPLE STRING PROCEDURE DEV_READ;
BEGIN ! reads BARM/YARM/POINTER (default=POINTER);
GTOKEN(FALSE);
IF EQU(TOKEN,"POINTER") OR EQU(TOKEN,"BARM") OR EQU(TOKEN,"YARM")
THEN RETURN(TOKEN)
ELSE IF FINAL OR TOKEN=";" THEN
BEGIN STOKEN←TRUE; RETURN("POINTER") END
ELSE BEGIN
PRINT($SYNMSG[18],"OR POINTER ",$SYNMSG[25]," OR",CRLF);
ERROR($SYNMSG[0],$SYNMSG[25]);
END;
END;
! returns the FROM frame "{FROM <frame>}" or STATION;
INTERNAL SIMPLE STRING PROCEDURE FROMPART;
BEGIN
STRING ROOT;
GTOKEN(FALSE);
IF EQU(TOKEN,"FROM")
THEN BEGIN ROOT←IDF_READ; RETURN(ROOT); END
ELSE IF FINAL
THEN RETURN("STATION")
ELSE BEGIN
PRINT($SYNMSG[0],$SYNMSG[25]," OR ");
ERROR("--→ FROM ",$SYNMSG[25]);
END;
END;
! input from different sources ;
INTERNAL PROCEDURE ASKUSER(STRING S(NULL));
BEGIN
PUSHDEVSTACK;
IF S=NULL
THEN BEGIN $CLNE←$CLINR←INCHWL; DEVICE←QUERY_X; END
ELSE BEGIN $CLNE←$CLINR←NULL; $CRBODY←S; DEVICE←PROGRAM_X; END;
END;
INTEGER $CVRTBREAK;
PROCEDURE INITCVRT;
SETBREAK($CVRTBREAK←GETBREAK,NULL,NULL,"K");
REQUIRE INITCVRT INITIALIZATION;
STRING PROCEDURE LISPMESS;
BEGIN
DEFINE MAIL = "710000000000";
STRING STR;INTEGER I;
INTEGER ARRAY MESS[1:32];
STR←NULL;
DO BEGIN
START_CODE
MAIL 1,ACCESS(MESS[1]);
END;
FOR I←1 STEP 1 UNTIL 31 DO STR←STR&CVASTR(MESS[I]);
END UNTIL MESS[32]=0;
RETURN(SCAN(STR,$CVRTBREAK,I));
END;
INTEGER TTYLINES;
INTERNAL PROCEDURE NEWLINE;
BEGIN
CHKESC_I;
CASE DEVICE OF
BEGIN
[QUERY_X] [MAC_X] [PROGRAM_X]
BEGIN
INTEGER BRCHAR;
IF $CRBODY THEN $CLNE←$CLINR←SCAN($CRBODY,$CRTAB,BRCHAR)
ELSE POPDEVSTACK;
END;
[TTY_X] BEGIN
IF STBEGIN THEN OUTSTR("* ") ELSE OUTSTR("***>>> ");
$CLNE←$CLINR←INCHWL;
IF $OUT THEN
BEGIN CPRINT($TTYCH,$CLNE,CRLF);
IF TTYLINES≥6 THEN
BEGIN UDATEFILE($TTYCH); TTYLINES←0; END
ELSE TTYLINES←TTYLINES+1;
END;
END;
[DSK_X] IF $EOF
THEN BEGIN $ALLOW←0; RELEASE($INPCH);
POPDEVSTACK; UPDATE;
END
ELSE BEGIN
$CLNE←$CLINR←INPUT($INPCH,$CRTAB);
IF NEWFILE THEN
BEGIN IF $CLNE[1 TO 17] =
"COMMENT ⊗ VALID"
THEN $CLNE←INPUT($INPCH,$FFTAB);
$CLNE←$CLINR←INPUT($INPCH,$CRTAB);
NEWFILE←FALSE;
END;
IF FILEPRINT THEN PRINT(CRLF,$CLNE);
END;
[MESSAGE_X]
BEGIN
OUTSTR("WAITING FOR MAIL... ");
$CLNE←$CLINR←LISPMESS;
OUTSTR("MAIL RECEIVED: "&$clne&crlf);
IF $OUT THEN BEGIN CPRINT($TTYCH,"{mail received}",$CLNE,CRLF);
IF TTYLINES≥6 THEN BEGIN UDATEFILE($TTYCH); TTYLINES←0; END
ELSE TTYLINES←TTYLINES+1;
END;
END;
ELSE BEGIN MTYDEVSTACK; ERROR("NO SUCH DEVICE"); END
END;
END;
END "SCANNER";